VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsHonGame"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Declare Function CreateSolidBrush Lib "gdi32.dll" (ByVal crColor As Long) As Long
Private Declare Function CreatePen Lib "gdi32.dll" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function Ellipse Lib "gdi32.dll" (ByVal hdc As Long, ByVal x1 As Long, ByVal y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function GetStockObject Lib "gdi32.dll" (ByVal nIndex As Long) As Long
Private Const NULL_BRUSH As Long = 5
Private Const NULL_PEN As Long = 8

Private Declare Function GetAsyncKeyState Lib "user32.dll" (ByVal vKey As Long) As Integer
Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)
Private Declare Function GetActiveWindow Lib "user32.dll" () As Long

Private Declare Function QueryPerformanceCounter Lib "kernel32.dll" (ByRef lpPerformanceCount As Currency) As Long
Private Declare Function QueryPerformanceFrequency Lib "kernel32.dll" (ByRef lpFrequency As Currency) As Long

Private Hon As clsHon

Private bm As New cDIBSection

Private objRnd As New clsMT19937

Private TheClrTable(1 To 15) As Long

Private TheTime As Long, sc As Long
Private scDel As Long
Private TheTimeM As Long
Private clrNow As Long
Private nLv As Long, nNext As Long, nNextM As Long

Private objCurrent(1 To 8) As Long
Private clrNext(1 To 8) As Long, nNextCount As Long
Private fNextMass(1 To 8) As Single

Private Const nColorMax As Long = 9

Private m_bRunning As Boolean, m_bGameOver As Boolean, m_bLastGameOver As Boolean

Private m_objCallback As clsHonGame, m_nUserData As Long
Private m_objInputCallback As IHonInputCallback

Private m_bIsComputer As Boolean
Private m_nComputerTime As Long, m_nComputerTime2 As Long

Private m_nKeyLeft As Long, m_nKeyRight As Long, m_nKeyDown As Long

Private m_nObstacle As Long, m_bLastObstacle As Boolean, m_nPlayerCount As Long

Implements clsHon

Private Type typeExplosion
 x As Single
 y As Single
 r As Single
 nTime As Long
 '0=unused
 '>0 used
 nColor As Long
 nReserved1 As Long
 nReserved2 As Long
 nReserved3 As Long
End Type

Private Const ExplosionMax As Long = 8, ExplosionTimeMax As Long = 8
Private m_tExplosion(1 To ExplosionMax) As typeExplosion

Private m_objQueue As clsHonQueue, m_nQueueIndex As Long

Friend Property Get RandomObject() As clsMT19937
Set RandomObject = objRnd
End Property

Friend Sub SetQueue(ByVal objQueue As clsHonQueue, Optional ByVal nQueueIndex As Long)
Set m_objQueue = objQueue
m_nQueueIndex = nQueueIndex
End Sub

Friend Property Get ObstacleCount() As Long
ObstacleCount = m_nObstacle
End Property

Friend Property Let ObstacleCount(ByVal n As Long)
m_nObstacle = n
End Property

Friend Property Get PlayerCount() As Long
PlayerCount = m_nPlayerCount
End Property

Friend Property Let PlayerCount(ByVal n As Long)
m_nPlayerCount = n
End Property

Friend Sub AddObstacle(ByVal n As Long)
m_nObstacle = m_nObstacle + n
End Sub

Friend Property Get IsComputer() As Boolean
IsComputer = m_bIsComputer
End Property

Friend Property Let IsComputer(ByVal b As Boolean)
m_bIsComputer = b
End Property

Friend Property Get KeyLeft() As KeyCodeConstants
KeyLeft = m_nKeyLeft
End Property

Friend Property Let KeyLeft(ByVal n As KeyCodeConstants)
m_nKeyLeft = n
End Property

Friend Property Get KeyRight() As KeyCodeConstants
KeyRight = m_nKeyRight
End Property

Friend Property Let KeyRight(ByVal n As KeyCodeConstants)
m_nKeyRight = n
End Property

Friend Property Get KeyDown() As KeyCodeConstants
KeyDown = m_nKeyDown
End Property

Friend Property Let KeyDown(ByVal n As KeyCodeConstants)
m_nKeyDown = n
End Property

Friend Property Get IsRunning() As Boolean
IsRunning = m_bRunning
End Property

Friend Property Get IsGameOver() As Boolean
IsGameOver = m_bGameOver
End Property

Friend Property Get LevelProgress() As Long
LevelProgress = nNext
End Property

Friend Property Let LevelProgress(ByVal n As Long)
nNext = n
End Property

Friend Property Get LevelProgressMax() As Long
LevelProgressMax = nNextM
End Property

Friend Property Let LevelProgressMax(ByVal n As Long)
nNextM = n
End Property

Friend Property Get ColorTable(ByVal nIndex As Long) As Long
ColorTable = TheClrTable(nIndex)
End Property

Friend Property Get RoundTime() As Long
RoundTime = TheTime
End Property

Friend Property Let RoundTime(ByVal n As Long)
TheTime = n
End Property

Friend Property Get Score() As Long
Score = sc
End Property

Friend Property Let Score(ByVal n As Long)
sc = n
End Property

Friend Property Get RoundTimeMax() As Long
RoundTimeMax = TheTimeM
End Property

Friend Property Let RoundTimeMax(ByVal n As Long)
TheTimeM = n
End Property

Friend Property Get CurrentMaxColor() As Long
CurrentMaxColor = clrNow
End Property

Friend Property Let CurrentMaxColor(ByVal n As Long)
clrNow = n
End Property

Friend Property Get CurrentLevel() As Long
CurrentLevel = nLv
End Property

Friend Property Let CurrentLevel(ByVal n As Long)
nLv = n
End Property

Public Sub OnLevelUpdate(ByVal This As clsHonGame, ByVal nUserData As Long, ByVal nLevel As Long)
'
End Sub

Public Sub OnNextLevel(ByVal This As clsHonGame, ByVal nUserData As Long, ByVal nLevel As Long)
'
End Sub

Public Sub OnLevelProgressUpdate(ByVal This As clsHonGame, ByVal nUserData As Long, ByVal nLevelProgress As Long, ByVal nLevelProgressMax As Long)
'
End Sub

Public Sub OnTimeUpdate(ByVal This As clsHonGame, ByVal nUserData As Long, ByVal nTime As Long, ByVal nTimeMax As Long)
'
End Sub

Public Sub OnNextItemUpdate(ByVal This As clsHonGame, ByVal nUserData As Long, ByVal nCount As Long, ByRef nColor() As Long, ByVal nReserved As Long)
'
End Sub

Public Sub OnScoreUpdate(ByVal This As clsHonGame, ByVal nUserData As Long, ByVal nScore As Long)
'
End Sub

Public Sub OnGameOver(ByVal This As clsHonGame, ByVal nUserData As Long, ByVal nScore As Long)
'
End Sub

Friend Property Get userdata() As Long
userdata = m_nUserData
End Property

Friend Property Let userdata(ByVal n As Long)
m_nUserData = n
End Property

Friend Property Get CallbackObject() As clsHonGame
Set CallbackObject = m_objCallback
End Property

Friend Property Set CallbackObject(ByVal obj As clsHonGame)
Set m_objCallback = obj
End Property

Friend Property Get InputCallback() As IHonInputCallback
Set InputCallback = m_objInputCallback
End Property

Friend Property Set InputCallback(ByVal obj As IHonInputCallback)
Set m_objInputCallback = obj
End Property

Friend Sub Init()
If Hon Is Nothing Then
 Set Hon = New clsHon
 Set Hon.CallbackObject = Me
 bm.Create 256, 384
 TheClrTable(1) = vbRed
 TheClrTable(2) = vbGreen
 TheClrTable(3) = vbBlue
 TheClrTable(4) = vbYellow
 TheClrTable(5) = vbMagenta
 TheClrTable(6) = vbCyan
 TheClrTable(7) = &H80FF&
 TheClrTable(8) = &H8000&
 TheClrTable(9) = &H808000
 '///
 TheClrTable(10) = &H808080
 TheClrTable(11) = vbWhite
End If
End Sub

Friend Property Get HonObject() As clsHon
Set HonObject = Hon
End Property

Friend Property Get BitmapObject() As cDIBSection
Set BitmapObject = bm
End Property

Friend Sub Clear()
m_bRunning = False
m_bGameOver = False
m_bLastGameOver = False
Erase objCurrent, m_tExplosion
TheTime = 0
sc = 0
scDel = 0
nLv = 1
Hon.Clear
End Sub

Friend Sub NewGame()
m_bRunning = True
m_bGameOver = False
m_bLastGameOver = False
Erase objCurrent
Erase m_tExplosion
TheTime = 0
m_nComputerTime = 60
m_nComputerTime2 = 30
sc = 0
scDel = 0
nLv = 1
m_nObstacle = 0
m_bLastObstacle = False
Hon.Clear
Hon.ColorMax = nColorMax
Hon.RockMax = nColorMax + 2
Hon.ExplosiveRock = nColorMax + 1
''////////////test only
'Dim i As Long
'For i = 1 To 100
' Hon.AddObj 256 * Rnd, 256 * Rnd, , , , , 1 + Int(nColorMax * Rnd)
'Next i
''////////////
UpdateLevelProperties
GenerateNextItem
ApplyNextItem
Redraw
End Sub

Friend Sub UpdateLevelProperties()
clrNow = (17 + nLv) \ 3
If clrNow > nColorMax Then clrNow = nColorMax
TheTimeM = 1536& \ (5 + nLv)
If TheTime > TheTimeM - 2 Then TheTime = TheTimeM - 2
nNext = 0
nNextM = (20 + nLv * 5) * 2&
'///
If Not m_objCallback Is Nothing Then
 m_objCallback.OnLevelUpdate Me, m_nUserData, nLv
End If
End Sub

'dreadful draw TODO:
Friend Sub Redraw()
Dim i As Long, j As Long
Dim fX As Single, fY As Single, k As Long, kk As Long
Dim x As Long, y As Long
Dim hbr As Long, hpn As Long, hpn1 As Long
bm.Cls
''///draw edges (??)
'hpn = SelectObject(bm.hdc, CreatePen(0, 1, vbWhite))
'DeleteObject SelectObject(bm.hdc, hpn)
'///draw balls
hpn = SelectObject(bm.hdc, GetStockObject(NULL_PEN))
For i = 1 To Hon.ObjCount
 If Hon.IsObject(i) Then
  Hon.GetObjData i, fX, fY, , k, kk
  x = fX
  y = 384 - fY
  Select Case k
  Case 1 To 15
   If (kk And 8&) = 0 Then
    hbr = SelectObject(bm.hdc, CreateSolidBrush(TheClrTable(k)))
    Ellipse bm.hdc, x - 15, y - 15, x + 15, y + 15
    DeleteObject SelectObject(bm.hdc, hbr)
   Else
    hpn1 = SelectObject(bm.hdc, CreatePen(0, 1, TheClrTable(k)))
    hbr = SelectObject(bm.hdc, GetStockObject(NULL_BRUSH))
    Ellipse bm.hdc, x - 15, y - 15, x + 15, y + 15
    SelectObject bm.hdc, hbr
    DeleteObject SelectObject(bm.hdc, hpn1)
   End If
  End Select
 End If
Next i
SelectObject bm.hdc, hpn
'///draw explosion
hbr = SelectObject(bm.hdc, GetStockObject(NULL_BRUSH))
For i = 1 To ExplosionMax
 k = m_tExplosion(i).nTime
 If k > 0 Then
  hpn = SelectObject(bm.hdc, CreatePen(0, 2, m_tExplosion(i).nColor))
  '///
  kk = k - 3
  If kk < 1 Then kk = 1
  If k > ExplosionTimeMax - 3 Then k = ExplosionTimeMax - 3
  x = m_tExplosion(i).x
  y = 384 - m_tExplosion(i).y
  For j = kk To k
   k = m_tExplosion(i).r * j / (ExplosionTimeMax - 3)
   Ellipse bm.hdc, x - k, y - k, x + k, y + k
  Next j
  '///
  DeleteObject SelectObject(bm.hdc, hpn)
 End If
Next i
SelectObject bm.hdc, hbr
'///over
End Sub

Friend Sub OnTimer()
Dim i As Long
Dim d As Long
'///
Dim bLeft As Boolean, bRight As Boolean, bDown As Boolean
Dim b As Boolean
'///
'calc time
TheTime = TheTime + 1
If TheTime >= TheTimeM Then
 'check game over??
 For i = 1 To 8
  d = objCurrent(i)
  If Hon.IsObject(d) Then
   If Hon.ObjY(d) > 384 Then 'And Abs(Hon.ObjVY(d)) < 48 Then
    '//////////////////////////GAME OVER (??)
    If m_bLastGameOver Then
     If Not m_objCallback Is Nothing Then
      m_objCallback.OnGameOver Me, m_nUserData, sc
     End If
     m_bRunning = False
     m_bGameOver = True
     Exit Sub
    Else
     b = True
    End If
    '//////////////////////////
'   Else 'enable collision with top
'    Hon.ObjFlags(d) = 1&
   End If
  End If
 Next i
 '///
 If b Or Not m_bLastObstacle Then
  m_bLastGameOver = b
 End If
 '///
 ApplyNextItem
 '///
 TheTime = 0
End If
'show time
If TheTimeM > 0 Then
 If Not m_objCallback Is Nothing Then
  m_objCallback.OnTimeUpdate Me, m_nUserData, TheTime, TheTimeM
 End If
End If
'///move it?
If Not m_objInputCallback Is Nothing Then
 m_objInputCallback.GetInput Me, m_nUserData, bLeft, bRight, bDown
ElseIf m_bIsComputer Then
 '///this is not AI LOL
 If m_nComputerTime And &H100& Then bLeft = True Else bRight = True
 If m_nComputerTime2 And &H100& Then bDown = True
 m_nComputerTime = m_nComputerTime - 1
 m_nComputerTime2 = m_nComputerTime2 - 1
 If (m_nComputerTime And &HFF&) = 0 Then m_nComputerTime = ((m_nComputerTime And &H100&) Xor &H100&) Or CLng(40 + 40 * objRnd.mt_random_real)
 If (m_nComputerTime2 And &HFF&) = 0 Then m_nComputerTime2 = ((m_nComputerTime2 And &H100&) Xor &H100&) Or CLng(20 + 30 * objRnd.mt_random_real)
 '///
Else
 bLeft = GetAsyncKeyState(m_nKeyLeft) And &H8000&
 bRight = GetAsyncKeyState(m_nKeyRight) And &H8000&
 bDown = GetAsyncKeyState(m_nKeyDown) And &H8000&
End If
If bLeft Then
 For i = 1 To 8
  d = objCurrent(i)
  If Hon.IsObject(d) Then
   Hon.ObjVX(d) = Hon.ObjVX(d) - 0.5
  End If
 Next i
ElseIf bRight Then
 For i = 1 To 8
  d = objCurrent(i)
  If Hon.IsObject(d) Then
   Hon.ObjVX(d) = Hon.ObjVX(d) + 0.5
  End If
 Next i
ElseIf bDown Then
 For i = 1 To 8
  d = objCurrent(i)
  If Hon.IsObject(d) Then
   Hon.ObjVY(d) = Hon.ObjVY(d) - 0.5
  End If
 Next i
End If
'calc next
''//////////test speed
'Dim t As Currency, tt As Currency
'QueryPerformanceCounter tt
Hon.Calc_RoundShaped 0.1, 5, , d
'QueryPerformanceCounter t
't = t - tt
'QueryPerformanceFrequency tt
'Me.Caption = Format(t * 1000 / tt, "0.00ms")
''//////////
If scDel > 0 Then
 scDel = scDel - 1
End If
If d > 0 Then
 nNext = nNext + d
 sc = sc + (scDel * d) \ 32& + (d * (d + 1)) \ 2&
 scDel = scDel + d * 32&
 '///
 If Not m_objCallback Is Nothing Then
  m_objCallback.OnLevelProgressUpdate Me, m_nUserData, nNext, nNextM
 End If
End If
'///
If Not m_objCallback Is Nothing Then
 m_objCallback.OnScoreUpdate Me, m_nUserData, sc
End If
'///
For i = 1 To ExplosionMax
 If m_tExplosion(i).nTime > 0 Then
  m_tExplosion(i).nTime = m_tExplosion(i).nTime + 1
  If m_tExplosion(i).nTime > ExplosionTimeMax Then
   m_tExplosion(i).nTime = 0
  End If
 End If
Next i
'///
Redraw
'///
If nNext > nNextM Then
 nLv = nLv + 1
 '///
 If Not m_objCallback Is Nothing Then
  m_objCallback.OnNextLevel Me, m_nUserData, nLv
 End If
 '///
 UpdateLevelProperties
 Erase objCurrent, m_tExplosion
 Hon.Clear
 TheTime = 0
 ApplyNextItem
End If
End Sub

'false=have obstacle
Friend Function ApplyNextItem() As Boolean
Dim idx(1 To 8) As Long
Dim i As Long, j As Long
Dim x As Long
'///
Erase objCurrent
'///
If m_nObstacle = 0 Or m_bLastObstacle Then
 m_bLastObstacle = False
 '///
 Select Case nNextCount
 Case 2
  x = 128 '16 + 224 * Rnd
  For i = 1 To 2
   idx(i) = Hon.AddObj(x, 496 - 32& * i, , , , , clrNext(i), , fNextMass(i))
   objCurrent(i) = idx(i)
  Next i
  Hon.AddEdge idx(1), idx(2)
 Case 3
  x = 128 '16 + 224 * Rnd
  For i = 1 To 3
   idx(i) = Hon.AddObj(x, 496 - 32& * i, , , , , clrNext(i), , fNextMass(i))
   objCurrent(i) = idx(i)
  Next i
  Hon.AddEdge idx(1), idx(2)
  Hon.AddEdge idx(2), idx(3)
 Case 4
  x = 112
  For i = 1 To 2
   idx(i) = Hon.AddObj(x, 496 - 32& * i, , , , , clrNext(i), , fNextMass(i))
   objCurrent(i) = idx(i)
   idx(i + 2) = Hon.AddObj(x + 32, 496 - 32& * i, , , , , clrNext(i + 2), , fNextMass(i + 2))
   objCurrent(i + 2) = idx(i + 2)
  Next i
  Hon.AddEdge idx(1), idx(2)
  Hon.AddEdge idx(1), idx(3)
  Hon.AddEdge idx(1), idx(4), 45.25483!
  Hon.AddEdge idx(2), idx(3), 45.25483!
  Hon.AddEdge idx(2), idx(4)
  Hon.AddEdge idx(3), idx(4)
 Case Else
  Debug.Assert False
 End Select
 '///
 GenerateNextItem
 '///
 ApplyNextItem = True
Else
 '///add obstacles
 If m_nPlayerCount < 2 Then m_nPlayerCount = 2
 m_nObstacle = (m_nObstacle + m_nPlayerCount - 2) \ m_nPlayerCount
 If m_nObstacle < 1 Then m_nObstacle = 1
 For i = 1 To m_nObstacle
  j = 1 + Int(8 * objRnd.mt_random_real)
  idx(j) = idx(j) + 1
 Next i
 For i = 1 To 8
  x = i * 32 - 16
  For j = 0 To idx(i) - 1
   Hon.AddObj x, 400 + j * 32, , , , , nColorMax + 2, , 0.5
  Next j
 Next i
 '///
 m_nObstacle = 0
 m_bLastObstacle = True
End If
End Function

Friend Sub GenerateNextItem()
Dim i As Long, j As Long, k As Long
Dim f As Single
Dim b As Boolean
'///
If Not m_objQueue Is Nothing Then
 b = m_objQueue.PopQueue(m_nQueueIndex, nNextCount, clrNext, fNextMass)
' 'debug
' If b Then Debug.Print "Pop" + CStr(m_nQueueIndex), m_objQueue.QueueStart, m_objQueue.QueueEnd, m_objQueue.ItemCount, m_objQueue.QueueMax
End If
If Not b Then
 i = Int(8 * objRnd.mt_random_real)
 Select Case i
 Case Is < 5
  nNextCount = 3
 Case Is < 7
  nNextCount = 4
 Case Else
  nNextCount = 2
 End Select
 '///
 For i = 1 To nNextCount
  Do
   '///
   Select Case CLng(Int((50 + nLv) * objRnd.mt_random_real))
   Case Is <= 48
    clrNext(i) = 1 + Int(clrNow * objRnd.mt_random_real)
   Case Is <= 51
    clrNext(i) = nColorMax + 1
   Case Else
    clrNext(i) = nColorMax + 2
   End Select
   '///
   k = 0
   For j = 1 To i - 1
    If clrNext(i) = clrNext(j) Then
     k = k + 1
     If k >= 2 Then Exit For
    End If
   Next j
  Loop While j < i
  '///
  Select Case clrNext(i)
  Case Is <= nColorMax
   f = 1
  Case nColorMax + 1
   f = 2 '12 '<--crazy
  Case nColorMax + 2
   f = 0.5
  Case Else
   Debug.Assert False
  End Select
  '///
  fNextMass(i) = f
 Next i
 '///
 If Not m_objQueue Is Nothing Then
  m_objQueue.PushQueue m_nQueueIndex, nNextCount, clrNext, fNextMass
'  'debug
'  Debug.Print "Push" + CStr(m_nQueueIndex), m_objQueue.QueueStart, m_objQueue.QueueEnd, m_objQueue.ItemCount, m_objQueue.QueueMax
 End If
End If
''///debug
'Open App.Path + "\Debug" + CStr(m_nQueueIndex) + ".txt" For Append As #1
'Print #1, "Debug", nNextCount, clrNext(1), clrNext(2), clrNext(3) And nNextCount >= 3, clrNext(4) And nNextCount >= 4
'Close
'///
If Not m_objCallback Is Nothing Then
 m_objCallback.OnNextItemUpdate Me, m_nUserData, nNextCount, clrNext, 0
End If
End Sub

Private Sub clsHon_OnExplosion(ByVal x As Single, ByVal y As Single, ByVal r As Single)
Dim i As Long
For i = 1 To ExplosionMax
 If m_tExplosion(i).nTime <= 0 Then
  m_tExplosion(i).x = x
  m_tExplosion(i).y = y
  m_tExplosion(i).r = r
  m_tExplosion(i).nColor = vbYellow
  m_tExplosion(i).nTime = 1
  Exit Sub
 End If
Next i
End Sub
